﻿{******************************************************************************}
{                                                                              }
{                                 UNIT WinACI                                  }
{                                                                              }
{  В этом модуле реализован класс для работы с Windows ACI*.                   }
{  This unit contains class for working with Windows ACI.                      }
{                                                                              }
{  * ACI - Application Compatibility Infrastructure.                           ]
{                                                                              }
{                       Copyright © 2010 by Xcentric                           }
{                                                                              }
{http://code.google.com/p/powered-by-delphi/                                   }
{******************************************************************************}

{

  ИСТОРИЯ ВЕРСИЙ / VERSION HISTORY:

  (1.1 | 25.07.2010)
    [*] Косметические изменения в методе TWinACIObject.SaveToRegistry

  (1.0 | 12.06.2010)
    Первый релиз модуля.
    First unit release.

}

unit WinACI;

interface

uses
  Windows, SysUtils, Registry;

const

  // Registry key:
  STR_ACIREGKEY = 'Software\Microsoft\Windows NT\CurrentVersion\AppCompatFlags\Layers';

  // Compatibility mode:
  STR_WIN95       = 'WIN95';        // Windows 95
  STR_WIN98       = 'WIN98';        // Windows 98/ME
  STR_NT4SP5      = 'NT4SP5';       // Windows NT 4 SP 5
  STR_WIN2000     = 'WIN2000';      // Windows 2000
  STR_WINXPSP2    = 'WINXPSP2';     // Windows XP SP2
  STR_WINXPSP3    = 'WINXPSP3';     // Windows XP SP3
  STR_WINSRV03SP1 = 'WINSRV03SP1';  // Windows Server 2003 SP1
  STR_WINSRV08SP1 = 'WINSRV08SP1';  // Windows Server 2008 SP1
  STR_VISTARTM    = 'VISTARTM';     // Windows Vista
  STR_VISTASP1    = 'VISTASP1';     // Windows Vista SP1
  STR_VISTASP2    = 'VISTASP2';     // Windows Vista SP2

  // Settings:
  STR_256COLOR      = '256Color';       // Run in 256 colors
  STR_640x480       = '640x480';        // Run in 640x480 screen resolution
  STR_DISABLETHEMES = 'DISABLETHEMES';  // Disable visual themes
  STR_DISABLEDWM    = 'DISABLEDWM';     // Disable desktop composition
  STR_HIGHDPIAWARE  = 'HIGHDPIAWARE';   // Disable display scaling on high DPI settings

  // Privilege level:
  STR_RUNASADMIN = 'RUNASADMIN';  // Run program as administrator

type

  // Compatibility mode:
  TCompatibilityMode = (cmNone, cmWin95, cmWin98, cmNT4SP5, cmWin2000, cmWinXPSP2,
                        cmWinXPSP3, cmWinSrv03SP1, cmWinSrv08SP1, cmVistaRTM,
                        cmVistaSP1, cmVistaSP2);

  // Compatibility settings:
  TCompatibilitySetting = (cs256Color, cs640x480, csDisableThemes, csDisableDWM, csHighDPIAware);
  TCompatibilitySettings = set of TCompatibilitySetting;

  // Privilege level:
  TPrivilegeLevel = (plDefault, plRunAsAdmin);

  ///  Class for working with Windows ACI:
  TWinACIObject = class
    strict private
      FReg : TRegistry;
      FAppPath : String;
      FCompatibilityMode : TCompatibilityMode;
      FCompatibilitySettings : TCompatibilitySettings;
      FPrivilegeLevel : TPrivilegeLevel;
    protected
      function  ComposeRegValue : String; virtual;
      procedure ParseRegValue(const RegValue : String); virtual;
    public
      constructor Create(const AppPath : String = '';
                         const ForAllUsers : Boolean = False); virtual;
      destructor Destroy; override;

      function SaveToRegistry : Boolean;
      function ReadFromRegistry : Boolean;

      property ApplicationPath : String read FAppPath;
      property Mode : TCompatibilityMode read  FCompatibilityMode
                                         write FCompatibilityMode;
      property Settings : TCompatibilitySettings read  FCompatibilitySettings
                                                 write FCompatibilitySettings;
      property PrivilegeLevel : TPrivilegeLevel read  FPrivilegeLevel
                                                write FPrivilegeLevel;
  end;

implementation

uses SysUtilsEx;

//------------------------------{ TWinACIObject }-------------------------------

///  Конструктор класса.
///  Первый параметр - путь к приложению.
///  Если не задан, то будет использован путь к данному приложению.
///  Второй параметр - чтение/запись параметров совместимости для всех пользователей.
///  Если True, то данные читаются/записываются из/в HKLM, что требует соответствующих прав.
///  Если False, то данные читаются/записываются из/в HKCU.
constructor TWinACIObject.Create(const AppPath : String = '';
                                 const ForAllUsers : Boolean = False);
begin
  Inherited Create;
  If (AppPath = '') Then FAppPath := ParamStr(0) Else FAppPath := AppPath;

  // Default parameters:
  FCompatibilityMode := cmNone;
  FCompatibilitySettings := [];
  FPrivilegeLevel := plDefault;

  FReg := TRegistry.Create;
  If ForAllUsers Then FReg.RootKey := HKEY_LOCAL_MACHINE
                 Else FReg.RootKey := HKEY_CURRENT_USER;
  ReadFromRegistry;
end;

destructor TWinACIObject.Destroy;
begin
  FReg.CloseKey;
  FreeAndNil(FReg);
  Inherited Destroy;
end;

///  Составление строки, которая будет записана в реестр, на основе
///  параметров, хранящихся в данном классе:
function TWinACIObject.ComposeRegValue : String;
begin
  // Mode:
  Case FCompatibilityMode of
    cmNone:        Result := '';
    cmWin95:       Result := STR_WIN95;
    cmWin98:       Result := STR_WIN98;
    cmNT4SP5:      Result := STR_NT4SP5;
    cmWin2000:     Result := STR_WIN2000;
    cmWinXPSP2:    Result := STR_WINXPSP2;
    cmWinXPSP3:    Result := STR_WINXPSP3;
    cmWinSrv03SP1: Result := STR_WINSRV03SP1;
    cmWinSrv08SP1: Result := STR_WINSRV08SP1;
    cmVistaRTM:    Result := STR_VISTARTM;
    cmVistaSP1:    Result := STR_VISTASP1;
    cmVistaSP2:    Result := STR_VISTASP2;
  End;

  // Settings:
  If (cs256Color in FCompatibilitySettings)
  Then Result := AddToken(Result, STR_256COLOR, ' ');
  If (cs640x480 in FCompatibilitySettings)
  Then Result := AddToken(Result, STR_640x480, ' ');
  If (csDisableThemes in FCompatibilitySettings)
  Then Result := AddToken(Result, STR_DISABLETHEMES, ' ');
  If (csDisableDWM in FCompatibilitySettings)
  Then Result := AddToken(Result, STR_DISABLEDWM, ' ');
  If (csHighDPIAware in FCompatibilitySettings)
  Then Result := AddToken(Result, STR_HIGHDPIAWARE, ' ');

  // Privilege level:
  Case FPrivilegeLevel of
    plRunAsAdmin: Result := AddToken(Result, STR_RUNASADMIN, ' ');
  End;
end;

///  Парсинг строки с параметрами совместимости, считанной из реестра,
///  с последующим распихиванием полученных данных по соответствующим полям.
///  Предполагается, что строка имеет правильный формат:
///  'CompatibilityMode + CompatibilitySettings + PrivilegeLevel'.
procedure TWinACIObject.ParseRegValue(const RegValue : String);
begin
  // Mode:
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_WIN95)
  Then FCompatibilityMode := cmWin95 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_WIN98)
  Then FCompatibilityMode := cmWin98 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_WIN2000)
  Then FCompatibilityMode := cmWin2000 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_NT4SP5)
  Then FCompatibilityMode := cmNT4SP5 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_WINXPSP2)
  Then FCompatibilityMode := cmWinXPSP2 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_WINXPSP3)
  Then FCompatibilityMode := cmWinXPSP3 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_WINSRV03SP1)
  Then FCompatibilityMode := cmWinSrv03SP1 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_WINSRV08SP1)
  Then FCompatibilityMode := cmWinSrv08SP1 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_VISTARTM)
  Then FCompatibilityMode := cmVistaRTM Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_VISTASP1)
  Then FCompatibilityMode := cmVistaSP1 Else
  If AnsiSameText(GetToken(RegValue, 1, ' '), STR_VISTASP2)
  Then FCompatibilityMode := cmVistaSP2 Else FCompatibilityMode := cmNone;

  // Settings:
  If TokenExists(RegValue, STR_256COLOR, ' ')
  Then FCompatibilitySettings := FCompatibilitySettings + [cs256Color];
  If TokenExists(RegValue, STR_640x480, ' ')
  Then FCompatibilitySettings := FCompatibilitySettings + [cs640x480];
  If TokenExists(RegValue, STR_DISABLETHEMES, ' ')
  Then FCompatibilitySettings := FCompatibilitySettings + [csDisableThemes];
  If TokenExists(RegValue, STR_DISABLEDWM, ' ')
  Then FCompatibilitySettings := FCompatibilitySettings + [csDisableDWM];
  If TokenExists(RegValue, STR_HIGHDPIAWARE, ' ')
  Then FCompatibilitySettings := FCompatibilitySettings + [csHighDPIAware];

  // Privilege level:
  If AnsiSameText(GetToken(RegValue, TokensNum(RegValue, ' '), ' '), STR_RUNASADMIN)
  Then FPrivilegeLevel := plRunAsAdmin Else FPrivilegeLevel := plDefault;
end;

///  Чтение параметров совместимости из реестра:
function TWinACIObject.ReadFromRegistry : Boolean;
begin
  Result := False;
  Try
    With FReg do
    begin
      If KeyExists(STR_ACIREGKEY) Then
      begin
        OpenKey(STR_ACIREGKEY, False);
        If ValueExists(FAppPath) Then ParseRegValue(ReadString(FAppPath));
        CloseKey;
      end;
    end;
  Except
    Exit;
  End;
  Result := True;
end;

///  Запись параметров совместимости в реестр:
function TWinACIObject.SaveToRegistry : Boolean;
  var
    sRegValue : String;
begin
  Result := False;
  Try
    With FReg do
    begin
      If KeyExists(STR_ACIREGKEY) Then
      begin
        OpenKey(STR_ACIREGKEY, False);
        sRegValue := ComposeRegValue;
        If (Length(sRegValue) <> 0) Then WriteString(FAppPath, sRegValue) Else
        If ValueExists(FAppPath) Then DeleteValue(FAppPath);
        CloseKey;
      end;
    end;
  Except
    Exit;
  End;
  Result := True;
end;

end.
